home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE11 / CONSOLE / CONSOLE.ZIP / CONSOLE.PAS next >
Encoding:
Pascal/Delphi Source File  |  1996-05-27  |  51.6 KB  |  1,892 lines
  1. unit Console;
  2. {$A+,B-,F-,Q-,R-,S-,W-,X+}
  3.  
  4. {  Text Console component
  5.    Version 2.0  for 16 bit and 32 bit Delphi.
  6.  
  7.    Copyright (c) 1995,96 by Danny Thorpe (dthorpe@subliminal.com)
  8.  
  9.    You are hereby granted a royalty-free unlimited distribution
  10.    license to compile the components in this source file into
  11.    your applications.
  12.  
  13.    This source file may be freely distributed through online networks
  14.    so long as no modifications are made to this file and no fee is
  15.    charged to obtain this file, other than normal online connection
  16.    charges.
  17.  
  18.    These components may NOT be distributed as source code or
  19.    compiled DCU on diskette, CDRom, or as part of a
  20.    product without prior written consent of the author.
  21.  
  22.    All rights not explicitly granted here are reserved by the author.
  23. }
  24.  
  25. interface
  26.  
  27. uses WinTypes, WinProcs, Messages, Classes, Controls,
  28.      Forms, Graphics, SysUtils;
  29.  
  30.  
  31. { TConsole
  32.  
  33.   TConsole implements a WinCRT-like control for routing text
  34.   file I/O (readlns and writelns) to a scrollable window.  A
  35.   text cursor can be positioned using X,Y text coordinates.
  36.   TConsole is not intended to be a text editor, merely a TTY
  37.   text output device.  TConsole does not store its text
  38.   buffers when it is streamed.  Max display text in 16 bit
  39.   applications is 64k (rows * columns <= 64k); in 32 bit
  40.   applications, the only capacity limit is system memory.
  41.   You can set the TConsole font name, style or other
  42.   properties, but only fixed-pitch fonts should be used.
  43.  
  44.   TConsole can be extended to support text color attributes
  45.   and multiple fonts, and can support multiple terminal
  46.   emulation command decoders (like ANSI-BBS or DEC VT-100).
  47.  
  48.   TConsole supports keyboard input via the Pascal standard
  49.   input functions ReadKey, Keypressed, and Readln.  Note that
  50.   the modal nature of Readln (execution doesn't return until
  51.   EOL is received) is problematic.  Only one outstanding
  52.   Console Readln operation is supported for the entire
  53.   application. Calling readln while another readln is
  54.   pending (eg Readln on a button click) will raise an
  55.   exception.
  56.  
  57.   TConsole provides a performance option called toLazyWrite.
  58.   With this option turned off, each write operation to the
  59.   Console is immediately displayed on the screen.  With
  60.   toLazyWrite turned on, screen updating is delayed slightly
  61.   so that multiple text changes can be displayed in one Paint
  62.   operation. Despite the 'lazy' name, this consolidation
  63.   results in dramatically better display performance - a
  64.   factor of 10 to 100 times faster than writing each little
  65.   piece of text immediately. toLazyWrite is enabled by default.
  66.  
  67.   The public ScrollTo and TrackCursor methods don't use
  68.   toLazyWrite, nor do the ReadKey or ReadBuf routines.  When
  69.   these routines modify the display or text buffer, the
  70.   Console is updated immediately.
  71.  
  72.   The coFixedPitchOnly option, True by default, determines whether
  73.   the console component raises an exception when a font which is not
  74.   marked as fixed pitch is assigned to the component.  Many off-brand
  75.   truetype fonts which have a uniform character width are
  76.   incorrectly marked as proportional fonts.  By setting
  77.   coFixedPitchOnly to false, you can now use those fonts in the
  78.   console components.  Using proportional fonts in a console
  79.   component is not advised; it's very ugly.
  80.  
  81. TColorConsole
  82.  
  83.   TColorConsole implements support for multiple text color
  84.   attributes.  The Console's font properties determine the
  85.   text color, background color, font, style, etc of the
  86.   display text.  Text foreground color is Console.Font.Color;
  87.   text background is Console.Font.BkColor.  Set the Console's
  88.   font properties, then writeln to the Console's text file
  89.   and that text will be displayed with those attributes.
  90.  
  91.   In 16 bit applications, TColorConsole has the following
  92.   capacity limits: Max display text is 32k. (rows * cols <= 32k).
  93.   Max unique text attribute sets: 16k. (unique = font+color+bkcolor)
  94.  
  95.   In 32 bit applications, the only limit is system memory.
  96.   Memory consumption is roughly 5 bytes per display text character
  97.   cell:  an 80 x 25 color console will use 80 x 25 = 2000 bytes
  98.   for the text buffer plus 80 x 25 x 4 = 8000 bytes for the
  99.   cell attribute buffer.  Each unique text attribute set uses
  100.   36 bytes of memory.
  101.  
  102.   Text attribute sets are maintained in a pool.  Each attr set
  103.   is released when the last char in the display buffer using
  104.   that set is overwritten with different attributes.
  105.  
  106.   Multiple fonts are supported, but the cell height and width
  107.   of the fonts must be the same.  That is, you can output text
  108.   in Courier New 10pt, Courier New 10pt Bold, and Lucida Sans
  109.   Monospace 10pt Italic all on the same screen.  If the
  110.   Console's font size is changed, that size change is applied
  111.   to all fonts used by the Console control and the control is
  112.   repainted.
  113.  
  114.   Fonts of the same height often have different widths.  When
  115.   a wider font is selected into the Console control, the
  116.   character cell dimensions for all the text is enlarged to
  117.   accommodate the wider font.  Characters of narrower fonts
  118.   will be spaced further apart to maintain column alignment.
  119.   This rarely looks appealing, so take it easy on the fonts.
  120.   TrueType fonts (like Courier New) tend to work better
  121.   than bitmap fonts (like Courier).
  122.  
  123.  
  124. TConsole's output routines
  125.  
  126.   Most of the time, you'll use a text file to write data to
  127.   the Console window.  To make the component intercept all output
  128.   written to stdout (ie anything that calls write or writeln
  129.   without a file handle), include the coStdOutput flag in the
  130.   component's Options property.  Only one component in the
  131.   application can intercept stdout.  coStdOutput is disabled by default.
  132.  
  133.   For more specialized work, such as extending these objects or
  134.   adding terminal emulation processor methods, you can use some
  135.   of TConsole's specialized output routines.
  136.  
  137. WriteChar
  138.   Calls WriteCodedBuf to output one character using the
  139.   current font/color attributes.
  140.  
  141. WriteString
  142.   Calls WriteCodedBuf to output the characters in the string
  143.   using the current font/color attributes.
  144.  
  145. WriteCodedBuf
  146.   Passes control to the ProcessControlCodes method pointer if
  147.   it is assigned.  If the pointer is not assigned, WriteBuf is
  148.   called instead. WriteCodedBuf is called by the internal text
  149.   file device driver (Write and Writeln), WriteChar, and
  150.   WriteString.
  151.  
  152.   Your ProcessControlCodes routine should parse the buffer to
  153.   find and execute complex display formatting control codes
  154.   and command sequences embedded in the data stream (such
  155.   as ANSI terminal codes).
  156.  
  157.   ProcessControlCodes is an event so that it can be reassigned
  158.   dynamically at runtime - for example, to switch from ANSI
  159.   emulation to Wyse terminal emulation.  Control code
  160.   processing methods have full responsibility for displaying
  161.   the actual text - they should parse their control codes,
  162.   set the cursor position or font/color attributes as
  163.   needed, and then call WriteChar, WriteString, or WriteFill
  164.   as necessary to display the actual text (without codes).
  165.  
  166.   If you determine that a text buffer contains no special
  167.   codes for your ProcessControlCodes event to handle, you
  168.   can pass the text buffer to DefaultProcessControlCodes
  169.   to perform the normal WriteBuf text processing on the buffer.
  170.   This will save you some work in your event handler.
  171.  
  172. WriteFill
  173.   Replicates a single character (or space) N times starting
  174.   from text coordinate X,Y and flowing down the page.
  175.   All the replicated chars are displayed with the currently
  176.   selected font and color attributes.  The copy count can be
  177.   any length up to (rows * cols).  TColorConsole overrides
  178.   this method to add additional color support.
  179.  
  180. WriteBuf
  181.   This is an internal (protected) mid-level method to process
  182.   simple text file formatting codes.  It scans the data stream
  183.   for special characters (Carriage return, Linefeed,
  184.   Backspace, Bell), wraps text at the right margin, and calls
  185.   WriteBlock or WriteFill for actual output.
  186.  
  187. WriteBlock
  188.   This is an internal (protected) low-level method to output
  189.   a string of characters.  WriteBlock assumes the string
  190.   parameter has been stripped of all special characters and
  191.   is guaranteed to contain no more than one line of text
  192.   (length <= Cols - Cursor.X).  All the characters in the
  193.   string are displayed with the currently selected font
  194.   and color attributes.  TColorConsole overrides this method
  195.   to add additional color support.
  196. }
  197.  
  198. const
  199.   CM_TrackCursor = wm_User + 100;
  200.   CM_ScrollBy    = wm_User + 101;
  201.  
  202. type
  203.   EInvalidFont = class(Exception);
  204.  
  205.   TCMScrollBy = record
  206.     Msg: Cardinal;
  207.     dx : Integer;
  208.     dy : Longint;
  209.   end;
  210.  
  211.   TConsole = class;  { forward declaration }
  212.  
  213.   TFixedFont = class(TFont)
  214.   private
  215.     FBkColor: TColor;
  216.     procedure SetBkColor(NewColor: TColor);
  217.   public
  218.     constructor Create;
  219.     procedure Assign(Source: TPersistent); override;
  220.   published
  221.     property BkColor: TColor read FBkColor write SetBkColor default clWindow;
  222.   end;
  223.  
  224.   TConsoleOption = (coAutoTracking, coCheckEOF, coCheckBreak,
  225.     coFulltimeCursor, coLazyWrite, coStdInput, coStdOutput, coFixedPitchOnly);
  226.   TConsoleOptions = set of TConsoleOption;
  227.  
  228.   { CR/LF translation.
  229.         CRLF = no translation
  230.         CR   = on CR add LF
  231.         LF   = on LF add CR   }
  232.   TConsoleLineBreak = (CRLF, CR, LF);
  233.  
  234.   TProcessControlCodes = procedure (Sender: TConsole;
  235.                     Buffer: PChar; Count: Cardinal) of object;
  236.  
  237.   TConsole = class(TCustomControl)
  238.   private
  239.     FOptions: TConsoleOptions;
  240.     FFocused: Boolean;
  241.     FFont: TFixedFont;
  242.     FCols: Integer;                        { Screen buffer dimensions }
  243.     FRows: Integer;
  244.     FProcessControlCodes: TProcessControlCodes;
  245.     FLineBreak: TConsoleLineBreak;        { CR/LF/CRLF translation }
  246.     procedure InternalClrScr;
  247.     procedure SetOptions(NewOptions: TConsoleOptions);
  248.     procedure SetCols(N: Integer);
  249.     procedure SetRows(N: Integer);
  250.     procedure SetFont(F: TFixedFont);
  251.     procedure DoScroll(Which, Action, Thumb: Integer);
  252.     procedure CMTrackCursor(var M); message CM_TrackCursor;
  253.     procedure CMScrollBy(var M: TCMScrollBy); message CM_ScrollBy;
  254.     procedure WMCreate(var M); message wm_Create;
  255.     procedure WMSize(var M: TWMSize); message wm_Size;
  256.     procedure WMHScroll(var M: TWMHScroll); message wm_HScroll;
  257.     procedure WMVScroll(var M: TWMVScroll); message wm_VScroll;
  258.     procedure WMSetFocus(var M: TWMSetFocus); message wm_SetFocus;
  259.     procedure WMKillFocus(var M: TWMKillFocus); message wm_KillFocus;
  260.     procedure WMGetDlgCode(var M: TWMGetDlgCode); message wm_GetDlgCode;
  261.     procedure WMEraseBkgnd(var M: TWMEraseBkgnd); message wm_EraseBkgnd;
  262.   protected
  263.     FReading: Boolean;                     { Reading from CRT window? }
  264.     FOldFont: TFixedFont;
  265.     FFirstLine: Integer;           { First visible line in circular buffer }
  266.     FKeyCount: Integer;                    { Count of keys in KeyBuffer }
  267.     FBuffer: PChar;                        { Screen buffer pointer }
  268.     FRange: TPoint;                        { Scroll bar ranges }
  269.     FOrigin: TPoint;                       { Client/scroll origin }
  270.     FClientSize: TPoint;                   { Number of visible whole cells }
  271.     FCharSize: TPoint;                     { Character cell size }
  272.     FCharAscent: Integer;                  { Baseline location (for caret) }
  273.     FOverhang: Integer;                    { Extra space needed for chars }
  274.     FKeyBuffer: array[0..63] of Char;      { Keyboard type-ahead buffer }
  275.     Cursor: TPoint;                        { Cursor location }
  276.     procedure CreateParams(var P: TCreateParams); override;
  277.     procedure FontChanged(Sender: TObject);
  278.     procedure ResizeBuffer; dynamic;
  279.     procedure SetName(const NewName: TComponentName); override;
  280.     procedure SetMetrics(const Metrics: TTextMetric); virtual;
  281.     procedure RecalibrateFont;
  282.     procedure RecalcSizeAndRange;
  283.     function  ScreenPtr(X, Y: Integer): PChar;
  284.     procedure ShowText(L, R: Integer);
  285.     procedure WriteBlock(X,Y: Integer; Buffer: PChar; Count: Cardinal); virtual;
  286.     procedure WriteBuf(Buffer: PChar; Count: Cardinal);
  287.     procedure SetScrollbars;
  288.     procedure Paint; override;
  289.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  290.     procedure KeyPress(var Key: Char); override;
  291.     procedure DoCtrlBreak; dynamic;
  292.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  293.          X, Y: Integer); override;
  294.     procedure LazyTrackCursor;
  295.     procedure LazyScrollBy(dx, dy: Integer);
  296.     procedure Loaded; override;
  297.   public
  298.     constructor Create(AnOwner: TComponent); override;
  299.     destructor Destroy; override;
  300.     procedure DefaultProcessControlCodes(Buffer: PChar; Count: Cardinal);
  301.     procedure WriteCodedBuf(Buffer: PChar; Count: Cardinal);
  302.     procedure WriteChar(Ch: Char);
  303.     procedure WriteFill(X,Y: Integer; Ch: Char; Count: Cardinal); virtual;
  304.     procedure WriteString(const S: String);
  305.     function  KeyPressed: Boolean;
  306.     function  ReadKey: Char;
  307.     function  ReadBuf(Buffer: PChar; Count: Cardinal): Cardinal;
  308.     procedure ClrScr;
  309.     procedure ClrEol;
  310.     procedure CursorTo(X, Y: Integer);
  311.     procedure ScrollTo(X, Y: Integer);
  312.     procedure TrackCursor;
  313.     procedure AssignCrt(var F: Text); dynamic;
  314.     procedure ShowCursor; virtual;
  315.     procedure HideCursor;
  316.   published
  317.     property Align;
  318.     property ParentColor;
  319.     property Color;
  320.     property Font: TFixedFont read FFont write SetFont;
  321.     property Options: TConsoleOptions read FOptions write SetOptions
  322.       default [coAutoTracking, coCheckBreak, coLazyWrite, coFixedPitchOnly];
  323.     property Cols: Integer read FCols write SetCols default 80;
  324.     property Rows: Integer read FRows write SetRows default 25;
  325.     property LineBreak: TConsoleLineBreak read FLineBreak write FLineBreak;
  326.     property ProcessControlCodes: TProcessControlCodes
  327.            read FProcessControlCodes write FProcessControlCodes;
  328.   end;
  329.  
  330.  
  331. type
  332.   PIntArray = ^TIntArray;
  333.   TIntArray = array [0..0] of Integer;
  334.  
  335. type
  336.   TAttr = class(TFixedFont)
  337.   protected
  338.     RefCount: Cardinal;
  339.     Overhang: ShortInt;
  340.     Underhang: ShortInt;
  341.   public
  342.     constructor Create(F: TFixedFont);
  343.   end;
  344.  
  345.   TAttrManager = class(TPersistent)
  346.   private
  347.     FList: TList;
  348.     FCache: TAttr;
  349.     FCacheIndex: Integer;
  350.     FFreeList: Integer;
  351.     function GetCount: Integer;
  352.   protected
  353.     function  GetAttr(Index: Integer): TAttr;
  354.     procedure SetAttr(Index: Integer; NewAttr: TAttr);
  355.     function  InFreeList(P: Pointer): Boolean;
  356.     function  FirstFreeIndex: Integer;
  357.     function  NextFreeIndex(P: Pointer): Integer;
  358.     procedure SetFree(Index: Integer);
  359.     function  AllocIndex: Integer;
  360.   public
  361.     constructor Create;
  362.     destructor Destroy; override;
  363.     function  Allocate(F: TFixedFont): Integer;
  364.     procedure Clear;
  365.     procedure Reference(Index: Integer; Delta: Integer);
  366.     property  Attr[Index: Integer]: TAttr read GetAttr write SetAttr; default;
  367.     property  Count: Integer read GetCount;
  368.   end;
  369.  
  370.   TColorConsole = class(TConsole)
  371.   private
  372.     FIndexes: PIntArray;
  373.     FAttrList: TAttrManager;
  374.     FCellWidths: PIntArray;
  375.     procedure FillAttr(X,Y: Integer; Count: Cardinal);
  376.   protected
  377.     function  IndexPtr(X,Y: Integer): PInteger;
  378.     procedure ResizeBuffer; override;
  379.     procedure SetMetrics(const Metrics: TTextMetric); override;
  380.     procedure WriteFill(X,Y: Integer; Ch: Char; Count: Cardinal); override;
  381.     procedure WriteBlock(X,Y: Integer; Buffer: PChar; Count: Cardinal); override;
  382.     procedure Paint; override;
  383.   public
  384.     constructor Create(Owner: TComponent); override;
  385.     destructor Destroy; override;
  386.   end;
  387.  
  388. procedure Register;
  389.  
  390. procedure Exchange(var X,Y: Pointer);
  391. procedure FillInt(var Buf; Count: Cardinal; Value: Integer);
  392.  
  393. implementation
  394.  
  395. { Scroll key definition record }
  396.  
  397. type
  398.   TScrollKey = record
  399.     sKey: Byte;
  400.     Ctrl: Boolean;
  401.     SBar: Byte;
  402.     Action: Byte;
  403.   end;
  404.  
  405. const
  406.   ReadActive: Boolean = False;  { Anybody in a Readln? }
  407.  
  408. { Scroll keys table }
  409.  
  410. const
  411.   ScrollKeyCount = 12;
  412.   ScrollKeys: array[1..ScrollKeyCount] of TScrollKey = (
  413.     (sKey: vk_Left;  Ctrl: False; SBar: sb_Horz; Action: sb_LineUp),
  414.     (sKey: vk_Right; Ctrl: False; SBar: sb_Horz; Action: sb_LineDown),
  415.     (sKey: vk_Left;  Ctrl: True;  SBar: sb_Horz; Action: sb_PageUp),
  416.     (sKey: vk_Right; Ctrl: True;  SBar: sb_Horz; Action: sb_PageDown),
  417.     (sKey: vk_Home;  Ctrl: False; SBar: sb_Horz; Action: sb_Top),
  418.     (sKey: vk_End;   Ctrl: False; SBar: sb_Horz; Action: sb_Bottom),
  419.     (sKey: vk_Up;    Ctrl: False; SBar: sb_Vert; Action: sb_LineUp),
  420.     (sKey: vk_Down;  Ctrl: False; SBar: sb_Vert; Action: sb_LineDown),
  421.     (sKey: vk_Prior; Ctrl: False; SBar: sb_Vert; Action: sb_PageUp),
  422.     (sKey: vk_Next;  Ctrl: False; SBar: sb_Vert; Action: sb_PageDown),
  423.     (sKey: vk_Home;  Ctrl: True;  SBar: sb_Vert; Action: sb_Top),
  424.     (sKey: vk_End;   Ctrl: True;  SBar: sb_Vert; Action: sb_Bottom));
  425.  
  426. { Return the smaller of two integer values }
  427.  
  428. function Min(X, Y: Integer): Integer;
  429. begin
  430.   if X < Y then Min := X else Min := Y;
  431. end;
  432.  
  433. { Return the larger of two integer values }
  434.  
  435. function Max(X, Y: Integer): Integer;
  436. begin
  437.   if X > Y then Max := X else Max := Y;
  438. end;
  439.  
  440. procedure Exchange(var X,Y: Pointer);
  441. var
  442.   Temp: Pointer;
  443. begin
  444.   Temp := X;
  445.   X := Y;
  446.   Y := Temp;
  447. end;
  448.  
  449. procedure FillInt(var Buf; Count: Cardinal; Value: Integer);
  450. {$IFDEF WIN32}
  451. {var
  452.   X: Cardinal;
  453. begin
  454.   for X := 0 to Count-1 do
  455.     TIntArray(Buf)[X] := Value;
  456. end;
  457. }register;
  458. asm
  459.   PUSH  EDI
  460.   MOV   EDI, EAX
  461.   MOV   EAX, ECX
  462.   MOV   ECX, EDX
  463.   CLD
  464.   REP   STOSD
  465.   POP   EDI
  466. end;
  467. {$ELSE}
  468. assembler;
  469. asm
  470.   PUSH DI
  471.   LES  DI, BUF
  472.   MOV  CX, COUNT
  473.   MOV  AX, VALUE
  474.   CLD
  475.   REP  STOSW
  476.   POP  DI
  477. end;
  478. {$ENDIF}
  479.  
  480. constructor TFixedFont.Create;
  481. begin
  482.   inherited Create;
  483.   Name := 'Courier New';
  484.   FBkColor := clWindow;
  485. end;
  486.  
  487. procedure TFixedFont.Assign(Source: TPersistent);
  488. var
  489.   Temp: TColor;
  490. begin
  491.   Temp := FBkColor;
  492.   if Source is TFixedFont then
  493.     FBkColor := TFixedFont(Source).BkColor;
  494.   try
  495.     inherited Assign(Source);        { inherited will call Changed }
  496.   except
  497.     FBkColor := Temp;   { Restore original if inherited fails }
  498.     raise;
  499.   end;
  500. end;
  501.  
  502. procedure TFixedFont.SetBkColor(NewColor: TColor);
  503. begin
  504.   FBkColor := NewColor;
  505.   Changed;
  506. end;
  507.  
  508.  
  509. constructor TConsole.Create(AnOwner: TComponent);
  510. begin
  511.   inherited Create(AnOwner);
  512.   Width := 160;
  513.   Height := 88;
  514.   Options := [coAutoTracking, coCheckBreak, coLazyWrite, coFixedPitchOnly];
  515.   ControlStyle := ControlStyle + [csOpaque];
  516.   FRows := 25;
  517.   FCols := 80;
  518.   ParentColor := False;
  519.   Color := clWindow;
  520.   FOldFont := TFixedFont.Create;
  521.   FOldFont.Handle := GetStockObject(Ansi_Fixed_Font);
  522.   FFont := TFixedFont.Create;
  523.   FFont.Name := 'Courier';
  524.   FFont.OnChange := FontChanged;
  525.   ResizeBuffer;
  526.   TabStop := True;
  527.   Enabled := True;
  528. end;
  529.  
  530. destructor TConsole.Destroy;
  531. begin
  532.   Options := Options - [coStdInput, coStdOutput];  { close files }
  533.   StrDispose(FBuffer);
  534.   FOldFont.Free;
  535.   FFont.Free;
  536.   inherited Destroy;
  537. end;
  538.  
  539. procedure TConsole.Loaded;
  540. begin
  541.   inherited Loaded;
  542.   ClrScr;
  543. end;
  544.  
  545. procedure TConsole.CreateParams(var P: TCreateParams);
  546. begin
  547.   inherited CreateParams(P);
  548.   P.WindowClass.Style := P.WindowClass.Style and not (cs_HRedraw or cs_VRedraw);
  549. end;
  550.  
  551. procedure TConsole.DefaultProcessControlCodes(Buffer: PChar; Count: Cardinal);
  552. begin
  553.   WriteBuf(Buffer, Count);
  554. end;
  555.  
  556. procedure TConsole.WMCreate(var M);
  557. begin
  558.   inherited;
  559.   RecalibrateFont;    { don't ClrScr, because text may already be in buffer }
  560. end;
  561.  
  562. procedure TConsole.ResizeBuffer;
  563. var Temp: PChar;
  564. begin
  565.   Temp := StrAlloc(Cols * Rows);
  566.   StrDispose(FBuffer);
  567.   FBuffer := Temp;
  568.   FillChar(FBuffer^,Cols * Rows,' ');
  569. end;
  570.  
  571. procedure TConsole.SetCols(N: Integer);
  572. begin
  573.   if FCols <> N then
  574.   begin
  575.     FCols := N;
  576.     ResizeBuffer;
  577.   end;
  578. end;
  579.  
  580. procedure TConsole.SetRows(N: Integer);
  581. begin
  582.   if FRows <> N then
  583.   begin
  584.     FRows := N;
  585.     ResizeBuffer;
  586.   end;
  587. end;
  588.  
  589. procedure TConsole.SetFont(F: TFixedFont);
  590. begin
  591.   FFont.Assign(F);
  592. end;
  593.  
  594. procedure TConsole.FontChanged(Sender: TObject);
  595. var
  596.   DC: HDC;
  597.   Save: THandle;
  598.   Metrics: TTextMetric;
  599.   Temp: String;
  600. begin
  601.   if Font.Handle <> FOldFont.Handle then
  602.   begin
  603.     DC := GetDC(0);
  604.     Save := SelectObject(DC, Font.Handle);
  605.     GetTextMetrics(DC, Metrics);
  606.     SelectObject(DC, Save);
  607.     ReleaseDC(0, DC);
  608.     if (coFixedPitchOnly in Options) and
  609.       not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and
  610.           ((Metrics.tmPitchAndFamily and $01) = 0)) then
  611.     begin
  612.       Temp := 'TConsole: ' + Font.Name + ' is not fixed-pitch';
  613.       Font.Name := FOldFont.Name;  { Keep other attributes of font }
  614.       raise EInvalidFont.Create(Temp);
  615.     end;
  616.     SetMetrics(Metrics);
  617.   end;
  618.   FOldFont.Assign(Font);
  619.   if csDesigning in ComponentState then
  620.     InternalClrScr;
  621. end;
  622.  
  623. { If the character cell is different, accept changes and redraw }
  624. procedure TConsole.SetMetrics(const Metrics: TTextMetric);
  625. begin
  626.   with Metrics do
  627.   begin
  628.     FCharSize.X := tmAveCharWidth;
  629.     FCharSize.Y := tmHeight + tmExternalLeading;
  630.     FCharAscent := tmAscent;
  631.     FOverhang   := Max(tmOverhang, tmMaxCharWidth - tmAveCharWidth);
  632.     Invalidate;
  633.     RecalcSizeAndRange;
  634.   end;
  635. end;
  636.  
  637. procedure TConsole.RecalcSizeAndRange;
  638. begin
  639.   if HandleAllocated then
  640.   begin
  641.     FClientSize.X := ClientWidth div FCharSize.X;
  642.     FClientSize.Y := ClientHeight div FCharSize.Y;
  643.     FRange.X := Max(0, Cols - FClientSize.X);
  644.     FRange.Y := Max(0, Rows - FClientSize.Y);
  645.     ScrollTo(Min(FOrigin.X, FRange.X), Min(FOrigin.Y, FRange.Y));
  646.     SetScrollBars;
  647.   end;
  648. end;
  649.  
  650. procedure TConsole.SetName(const NewName: TComponentName);
  651. begin
  652.   inherited SetName(NewName);
  653.   if csDesigning in ComponentState then
  654.     ClrScr;
  655. end;
  656.  
  657.  
  658. { Return pointer to text location in screen buffer }
  659. { Always call ScreenPtr to get the next line you want, since the
  660.   circular text buffer may wrap around between lines N and N+1.
  661.   For the same reason, do not do pointer arithmetic between rows. }
  662.  
  663. function TConsole.ScreenPtr(X, Y: Integer): PChar;
  664. begin
  665.   Inc(Y, FFirstLine);
  666.   if Y >= Rows then Dec(Y, Rows);
  667.   Result := @FBuffer[Y * Cols + X];
  668. end;
  669.  
  670. { Update text on cursor line }
  671.  
  672. procedure TConsole.ShowText(L, R: Integer);
  673. var
  674.   B: TRect;
  675. begin
  676.   if HandleAllocated and (L < R) then
  677.   begin
  678.     B.Left := (L - FOrigin.X) * FCharSize.X;
  679.     B.Top  := (Cursor.Y - FOrigin.Y) * FCharSize.Y;
  680.     B.Right:= (R - FOrigin.X) * FCharSize.X + FOverhang;
  681.     B.Bottom := B.Top + FCharSize.Y;
  682.     InvalidateRect(Handle, @B, False);
  683.     if not (coLazyWrite in Options) then
  684.       Update;
  685.   end;
  686. end;
  687.  
  688. { Show caret }
  689.  
  690. procedure TConsole.ShowCursor;
  691. begin
  692.   if not HandleAllocated then Exit;
  693.   CreateCaret(Handle, 0, FCharSize.X, 2);
  694.   SetCaretPos((Cursor.X - FOrigin.X) * FCharSize.X,
  695.     (Cursor.Y - FOrigin.Y) * FCharSize.Y + FCharAscent);
  696.   ShowCaret(Handle);
  697. end;
  698.  
  699. { Hide caret }
  700.  
  701. procedure TConsole.HideCursor;
  702. begin
  703.   DestroyCaret;
  704. end;
  705.  
  706. { Set cursor position }
  707.  
  708. procedure TConsole.CursorTo(X, Y: Integer);
  709. begin
  710.   Cursor.X := Max(0, Min(X, Cols - 1));
  711.   Cursor.Y := Max(0, Min(Y, Rows - 1));
  712.   if FFocused and (FReading or (coFullTimeCursor in Options)) then
  713.     ShowCursor;
  714. end;
  715.  
  716. { Request asynchronous (lazy) ScrollBy, or update pending request }
  717.  
  718. procedure TConsole.LazyScrollBy(dx, dy: Integer);
  719. var
  720.   Msg: TMsg;
  721. begin
  722.   if (coLazyWrite in Options) and HandleAllocated then
  723.   begin
  724.     if PeekMessage(Msg, Handle, cm_ScrollBy,
  725.          cm_ScrollBy, PM_NoYield or PM_Remove) then
  726.     begin
  727.       Inc(dx, Msg.WParam);
  728.       Inc(dy, Msg.LParam);
  729.     end;          { Flush accumulated scroll when delta >= half a screen }
  730.     if (Abs(dx) >= Min(FClientSize.X, Cols) div 2) or
  731.        (Abs(dy) >= Min(FClientSize.Y, Rows) div 2) then
  732.       Perform(CM_ScrollBy, dx, dy)
  733.     else
  734.       if (dx or dy) <> 0 then
  735.         PostMessage(Handle, cm_ScrollBy, dx, dy);
  736.   end
  737.   else
  738.     Perform(CM_ScrollBy, dx, dy);
  739. end;
  740.  
  741. { Respond to asynchronous (lazy) ScrollBy request }
  742.  
  743. procedure TConsole.CMScrollBy(var M: TCMScrollBy);
  744. begin
  745.   ScrollTo(FOrigin.X + M.dx, FOrigin.Y + M.dy);
  746. end;
  747.  
  748.  
  749. { Scroll window to given origin }
  750. { If font has overlapping cells (ie, italic), additional work is done to
  751.   remove the residual overlapped pixels from the leftmost column.
  752.   Using the clip rect with ScrollWindowEx helps eliminate pixel flicker in
  753.   the left column.  }
  754. procedure TConsole.ScrollTo(X, Y: Integer);
  755. var
  756.   R: TRect;
  757.   OldOrigin: TPoint;
  758. begin
  759.   X := Max(0, Min(X, FRange.X));
  760.   Y := Max(0, Min(Y, FRange.Y));
  761.   if (X <> FOrigin.X) or (Y <> FOrigin.Y) then
  762.   begin
  763.     OldOrigin := FOrigin;
  764.     FOrigin.X := X;
  765.     FOrigin.Y := Y;
  766.     if HandleAllocated then
  767.     begin
  768.       R := ClientRect;
  769.       if X > OldOrigin.X then Inc(R.Left, FOverhang);
  770.       if Y > OldOrigin.Y then R.Bottom := FClientSize.Y * FCharSize.Y;
  771.       ScrollWindowEx(Handle,
  772.        (OldOrigin.X - X) * FCharSize.X,
  773.        (OldOrigin.Y - Y) * FCharSize.Y, nil, @R, 0, @R, 0);
  774.       if Y <> OldOrigin.Y then
  775.       begin
  776.         SetScrollPos(Handle, sb_Vert, Y, True);
  777.         if Y > OldOrigin.Y then
  778.         begin
  779.           InvalidateRect(Handle, @R, False);
  780.           Update;
  781.           R.Top := R.Bottom;
  782.           R.Bottom := ClientRect.Bottom;
  783.         end;
  784.       end;
  785.       if X <> OldOrigin.X then
  786.       begin
  787.         SetScrollPos(Handle, sb_Horz, X, True);
  788.         if (FOverhang > 0) then
  789.         begin
  790.           if (X < OldOrigin.X) then { Scroll right - left edge repaint }
  791.           begin
  792.           { Add overhang to invalidation rect to redraw leftmost char pair }
  793.             R.Left := 0;
  794.             R.Right := Max(R.Right, (OldOrigin.X - X) * FCharSize.X + FOverhang);
  795.           end
  796.           else    { Scroll left - right edge repaint }
  797.           begin
  798.             { Redraw leftmost chars to remove prev chars' overhang }
  799.             InvalidateRect(Handle, @R, False);
  800.             Update;   { Update right side, before invalidating left side }
  801.             R.Left := 0;
  802.             R.Top  := 0;
  803.             R.Right := FOverhang;
  804.             R.Bottom := ClientHeight;
  805.           end;
  806.         end;
  807.       end;
  808.       InvalidateRect(Handle, @R, False);
  809.       Update;
  810.     end;
  811.   end;
  812. end;
  813.  
  814. { Request asynchronous (lazy) TrackCursor, if not already pending }
  815.  
  816. procedure TConsole.LazyTrackCursor;
  817. var
  818.   Msg: TMsg;
  819. begin
  820.   if (coLazyWrite in Options) and HandleAllocated then
  821.   begin   { Only post msg if there is not one already in the queue }
  822.     if not PeekMessage(Msg, Handle, cm_TrackCursor,
  823.              cm_TrackCursor, PM_NoYield or PM_NoRemove) then
  824.       PostMessage(Handle, cm_TrackCursor, 0, 0);
  825.   end
  826.   else
  827.     TrackCursor;
  828. end;
  829.  
  830. { Respond to asynchronous (lazy) TrackCursor request }
  831.  
  832. procedure TConsole.CMTrackCursor(var M);
  833. begin
  834.   TrackCursor;
  835. end;
  836.  
  837. { Scroll to make cursor visible (synchronous - immediate update)}
  838.  
  839. procedure TConsole.TrackCursor;
  840. begin
  841.   ScrollTo(Max(Cursor.X - FClientSize.X + 1, Min(FOrigin.X, Cursor.X)),
  842.     Max(Cursor.Y - FClientSize.Y + 1, Min(FOrigin.Y, Cursor.Y)));
  843. end;
  844.  
  845. { Update scroll bars }
  846.  
  847. procedure TConsole.SetScrollBars;
  848. begin
  849.   if not HandleAllocated then Exit;
  850.   SetScrollRange(Handle, sb_Horz, 0, Max(1, FRange.X), False);
  851.   SetScrollPos(Handle, sb_Horz, FOrigin.X, True);
  852.   SetScrollRange(Handle, sb_Vert, 0, Max(1, FRange.Y), False);
  853.   SetScrollPos(Handle, sb_Vert, FOrigin.Y, True);
  854. end;
  855.  
  856. { Clear screen }
  857.  
  858. procedure TConsole.InternalClrScr;
  859. begin
  860.   WriteFill(0,0,' ',Cols * Rows);
  861.   FOrigin.X := 0;
  862.   FOrigin.Y := 0;
  863.   Cursor.X := 0;
  864.   Cursor.Y := 0;
  865.   if (csDesigning in ComponentState) then
  866.     WriteString(Name);
  867.   Invalidate;
  868. end;
  869.  
  870. procedure TConsole.ClrScr;
  871. begin
  872.   InternalClrScr;
  873.   RecalibrateFont;
  874. end;
  875.  
  876. procedure TConsole.RecalibrateFont;
  877. begin
  878.   FCharSize.X := 0;
  879.   FCharSize.Y := 0;
  880.   FCharAscent := 0;
  881.   FOverhang := 0;
  882.   FOldFont.Handle := 0;
  883.   FOldFont.Size := 0;
  884.   FontChanged(FFont);   { This will force a repaint and recalibrate }
  885. end;
  886.  
  887. { Clear to end of line }
  888.  
  889. procedure TConsole.ClrEol;
  890. begin
  891.   WriteFill(Cursor.X, Cursor.Y, ' ', Cols - Cursor.X);
  892.   ShowText(Cursor.X, Cols);
  893. end;
  894.  
  895.  
  896. procedure TConsole.WriteBlock(X,Y: Integer; Buffer: PChar; Count: Cardinal);
  897. begin
  898.   Move(Buffer^, ScreenPtr(X,Y)^, Count);
  899. end;
  900.  
  901.  
  902. { Write text buffer to CRT window
  903.    - Process any special characters in buffer
  904.    - Insert line breaks
  905. }
  906. procedure TConsole.WriteBuf(Buffer: PChar; Count: Cardinal);
  907. var
  908.   L, R: Integer;
  909.  
  910.   procedure Return;
  911.   begin
  912.     L := 0;
  913.     R := 0;
  914.     Cursor.X := 0;
  915.   end;
  916.  
  917.   procedure LineFeed;
  918.   var
  919.     Rect: TRect;
  920.   begin
  921.     Inc(Cursor.Y);
  922.     if Cursor.Y = Rows then
  923.     begin
  924.       Dec(Cursor.Y);
  925.       Inc(FFirstLine);
  926.       if FFirstLine = Rows then FFirstline := 0;
  927.       WriteFill(0, Cursor.Y, ' ', Cols);
  928.       Dec(FOrigin.Y, 1);
  929.       LazyScrollBy(0, 1);
  930.     end;
  931.   end;
  932.  
  933. var
  934.   BlockEnd, BlockLen, BlockStart: Integer;
  935.   P: PChar;
  936.  
  937. begin
  938.   L := Cursor.X;
  939.   R := Cursor.X;
  940.   while Count > 0 do
  941.   begin
  942.     BlockEnd := Min(Cols - Cursor.X, Count);
  943.     P := Buffer;
  944. {$IFDEF WIN32}
  945.     BlockStart := BlockEnd;
  946.     while (BlockEnd > 0) and (Buffer^ in [#32..#255]) do
  947.     begin
  948.       Inc(Buffer);
  949.       Dec(BlockEnd);
  950.     end;
  951.     BlockLen := BlockStart - BlockEnd;
  952. {$ELSE}
  953.     asm
  954.       PUSH   DS
  955.       PUSH   SI
  956.       LDS    SI, Buffer
  957.       MOV    CX, BlockEnd
  958.       MOV    DX, CX
  959.       CLD
  960.     @@1:
  961.       LODSB
  962.       CMP    AL,' '
  963.       JB     @@2
  964.       LOOP   @@1
  965.       INC    SI
  966.     @@2:
  967.       DEC    SI
  968.       MOV    Buffer.Word[0],SI
  969.       MOV    BlockEnd, CX
  970.       SUB    DX,CX
  971.       MOV    BlockLen, DX
  972.       POP    SI
  973.       POP    DS
  974.     end;
  975. {$ENDIF}
  976.     if BlockLen > 0 then
  977.     begin
  978.       Dec(Count, BlockLen);
  979.       WriteBlock(Cursor.X, Cursor.Y, P, BlockLen);
  980.       Inc(Cursor.X, BlockLen);
  981.       if Cursor.X > R then R := Cursor.X;
  982.  
  983.       if (BlockEnd = 0) and (Cursor.X >= Cols) then
  984.       begin
  985.         ShowText(L,R);
  986.         Return;
  987.         LineFeed;
  988.         Continue;
  989.       end;
  990.     end;
  991.  
  992.     if Count > 0 then
  993.     begin
  994.       case Buffer^ of
  995.         #13: begin
  996.               ShowText(L,R);
  997.               Return;
  998.               if LineBreak = CR then LineFeed;
  999.             end;
  1000.         #10: begin
  1001.               ShowText(L,R);
  1002.               if LineBreak = LF then Return;
  1003.               LineFeed;
  1004.             end;
  1005.           #8: if Cursor.X > 0 then
  1006.             begin
  1007.               Dec(Cursor.X);
  1008.               WriteFill(Cursor.X, Cursor.Y, ' ', 1);
  1009.               if Cursor.X < L then L := Cursor.X;
  1010.             end;
  1011.         #7: MessageBeep(0);
  1012.       end;
  1013.       Inc(Buffer);
  1014.       Dec(Count);
  1015.     end;
  1016.   end;
  1017.   ShowText(L, R);
  1018.   if coAutoTracking in Options then
  1019.     LazyTrackCursor;
  1020.   if FFocused and (coFullTimeCursor in Options) then
  1021.     ShowCursor;
  1022. end;
  1023.  
  1024. procedure TConsole.WriteCodedBuf(Buffer: PChar; Count: Cardinal);
  1025. begin
  1026.   if Assigned(FProcessControlCodes) then
  1027.     FProcessControlCodes(Self, Buffer, Count)
  1028.   else
  1029.     WriteBuf(Buffer, Count);
  1030. end;
  1031.  
  1032. { Write character to CRT window }
  1033.  
  1034. procedure TConsole.WriteChar(Ch: Char);
  1035. begin
  1036.   WriteCodedBuf(@Ch, 1);
  1037. end;
  1038.  
  1039. procedure TConsole.WriteString(const S: String);
  1040. begin
  1041.   WriteCodedBuf(@S[1], Length(S));
  1042. end;
  1043.  
  1044. procedure TConsole.WriteFill(X,Y: Integer; Ch: Char; Count: Cardinal);
  1045. var
  1046.   I: Integer;
  1047. begin
  1048.   if Count = 0 then Exit;
  1049.   if (X + Count) > Cols then
  1050.   begin
  1051.     FillChar(ScreenPtr(X,Y)^, Cols - X, Ch);
  1052.     Dec(Count, Cols - X);
  1053.     I := Cols;
  1054.     while Count > 0 do
  1055.     begin
  1056.       Inc(Y);
  1057.       FillChar(ScreenPtr(X,Y)^, I, Ch);
  1058.       Dec(Count, I);
  1059.     end;
  1060.   end
  1061.   else
  1062.     FillChar(ScreenPtr(X,Y)^, Count, Ch);
  1063. end;
  1064.  
  1065. { Return keyboard status }
  1066.  
  1067. function TConsole.KeyPressed: Boolean;
  1068. begin
  1069.   Result := FKeyCount > 0;
  1070.   if (not Result) then
  1071.   begin
  1072.     Application.ProcessMessages;
  1073.     Result := FKeyCount > 0;
  1074.   end;
  1075. end;
  1076.  
  1077. { Read key from CRT window }
  1078.  
  1079. function TConsole.ReadKey: Char;
  1080. begin
  1081.   TrackCursor;
  1082.   if not KeyPressed then
  1083.   begin
  1084.     SetFocus;
  1085.     if FReading or ReadActive then
  1086.       raise EInvalidOperation.Create('Read already active');
  1087.     try
  1088.       FReading := True;
  1089.       ReadActive := True;
  1090.       if FFocused then ShowCursor;
  1091.       repeat
  1092.         Application.HandleMessage
  1093.       until Application.Terminated or (FKeyCount > 0);
  1094.       if Application.Terminated then
  1095.         raise Exception.Create('WM_Quit received during ReadKey');
  1096.     finally
  1097.       if FFocused and not (coFullTimeCursor in Options) then
  1098.         HideCursor;
  1099.       FReading := False;
  1100.       ReadActive := False;
  1101.     end;
  1102.   end;
  1103.   ReadKey := FKeyBuffer[0];
  1104.   Dec(FKeyCount);
  1105.   Move(FKeyBuffer[1], FKeyBuffer[0], FKeyCount);
  1106. end;
  1107.  
  1108. { Read text buffer from CRT window }
  1109.  
  1110. function TConsole.ReadBuf(Buffer: PChar; Count: Cardinal): Cardinal;
  1111. var
  1112.   Ch: Char;
  1113.   I: Cardinal;
  1114. begin
  1115.   I := 0;
  1116.   repeat
  1117.     Ch := ReadKey;
  1118.     case Ch of
  1119.       #8:
  1120.         if I > 0 then
  1121.         begin
  1122.           Dec(I);
  1123.           WriteChar(#8);
  1124.         end;
  1125.       #32..#255:
  1126.         if I < Count - 2 then
  1127.         begin
  1128.           Buffer[I] := Ch;
  1129.           Inc(I);
  1130.           WriteChar(Ch);
  1131.         end;
  1132.     end;
  1133.   until (Ch in [#0,#13]) or ((coCheckEOF in Options) and (Ch = #26));
  1134.   Buffer[I] := Ch;
  1135.   Inc(I);
  1136.   if Ch = #13 then
  1137.   begin
  1138.     Buffer[I] := #10;
  1139.     Inc(I);
  1140.     WriteBuf(#13#10,2);
  1141.   end;
  1142.   TrackCursor;
  1143.   ReadBuf := I;
  1144.   if FFocused and (coFullTimeCursor in Options) then ShowCursor;
  1145. end;
  1146.  
  1147.  
  1148. { Text file device driver output function }
  1149.  
  1150. function CrtOutput(var F: TTextRec): Integer; far;
  1151. begin
  1152.   if F.BufPos <> 0 then
  1153.   with TObject((@F.UserData)^) as TConsole do
  1154.   begin
  1155.     WriteCodedBuf(PChar(F.BufPtr), F.BufPos);
  1156.     F.BufPos := 0;
  1157.   end;
  1158.   CrtOutput := 0;
  1159. end;
  1160.  
  1161. { Text file device driver input function }
  1162.  
  1163. function CrtInput(var F: TTextRec): Integer; far;
  1164. begin
  1165.   with TObject((@F.UserData)^) as TConsole do
  1166.     F.BufEnd := ReadBuf(PChar(F.BufPtr), F.BufSize);
  1167.   F.BufPos := 0;
  1168.   CrtInput := 0;
  1169. end;
  1170.  
  1171. { Text file device driver close function }
  1172.  
  1173. function CrtClose(var F: TTextRec): Integer; far;
  1174. begin
  1175.   CrtClose := 0;
  1176. end;
  1177.  
  1178. { Text file device driver open function }
  1179.  
  1180. function CrtOpen(var F: TTextRec): Integer; far;
  1181. begin
  1182.   if F.Mode = fmInput then
  1183.   begin
  1184.     F.InOutFunc := @CrtInput;
  1185.     F.FlushFunc := nil;
  1186.   end else
  1187.   begin
  1188.     F.Mode := fmOutput;
  1189.     F.InOutFunc := @CrtOutput;
  1190.     F.FlushFunc := @CrtOutput;
  1191.   end;
  1192.   F.CloseFunc := @CrtClose;
  1193.   CrtOpen := 0;
  1194. end;
  1195.  
  1196. { Assign text file to CRT device }
  1197.  
  1198. procedure TConsole.AssignCrt(var F: Text);
  1199. begin
  1200.   with TTextRec(F) do
  1201.   begin
  1202.     Handle := Cardinal(-1);
  1203.     Mode := fmClosed;
  1204.     BufSize := SizeOf(Buffer);
  1205.     BufPtr := @Buffer;
  1206.     OpenFunc := @CrtOpen;
  1207.     Move(Self, UserData[1],Sizeof(Pointer));
  1208.     Name[0] := #0;
  1209.   end;
  1210. end;
  1211.  
  1212. procedure TConsole.SetOptions(NewOptions: TConsoleOptions);
  1213. begin
  1214.   if not (csDesigning in ComponentState) then { don't open files at design time }
  1215.   begin
  1216.     if (coStdInput in (NewOptions - Options)) then
  1217.       with TTextRec(Input) do
  1218.       begin
  1219.         if (Mode <> fmClosed) and (Mode <> 0) then
  1220.           raise Exception.Create('TConsole.SetOptions: Standard Input is already open');
  1221.         AssignCrt(Input);
  1222.         Reset(Input);
  1223.         Include(FOptions, coStdInput);  { in case opening output fails }
  1224.       end
  1225.     else
  1226.       if (coStdInput in (Options - NewOptions)) then
  1227.         System.Close(Input);
  1228.  
  1229.     if (coStdOutput in (NewOptions - Options)) then
  1230.       with TTextRec(Output) do
  1231.       begin
  1232.         if (Mode <> fmClosed) and (Mode <> 0) then
  1233.           raise Exception.Create('TConsole.SetOptions: Standard Output is already open');
  1234.         AssignCrt(Output);
  1235.         Rewrite(Output);
  1236.       end
  1237.     else
  1238.       if (coStdOutput in (Options - NewOptions)) then
  1239.         System.Close(Output);
  1240.   end;
  1241.   FOptions := NewOptions;
  1242. end;
  1243.  
  1244.  
  1245. { wm_Paint message handler }
  1246.  
  1247. procedure TConsole.Paint;
  1248. var
  1249.   X1, X2, Y1, Y2, PX, PY: Integer;
  1250.   R: TRect;
  1251. begin
  1252.   Canvas.Font := Font;
  1253.   Canvas.Brush.Color := Font.BkColor;
  1254.   SetViewportOrgEx(Canvas.Handle, -FOrigin.X * FCharSize.X, -FOrigin.Y * FCharSize.Y, nil);
  1255.   GetClipBox(Canvas.Handle, R);
  1256.   X1 := Max(FOrigin.X, (R.left - FOverhang) div FCharSize.X);
  1257.   X2 := Min(Cols, (R.right + FCharSize.X) div FCharSize.X);
  1258.   Y1 := Max(0, R.top div FCharSize.Y);
  1259.   Y2 := Min(Rows, (R.bottom + FCharSize.Y - 1) div FCharSize.Y);
  1260.   PX := X1 * FCharSize.X;
  1261.   PY := Y1 * FCharSize.Y;
  1262.   { Draw first line using ETO_Opaque and the entire clipping region. }
  1263.   ExtTextOut(Canvas.Handle, PX, PY, ETO_Opaque, @R, ScreenPtr(X1, Y1), X2 - X1, nil);
  1264.   Inc(Y1);
  1265.   Inc(PY, FCharSize.Y);
  1266.   while Y1 < Y2 do
  1267.   begin
  1268.     { Draw subsequent lines without any background fill or clipping rect }
  1269.     ExtTextOut(Canvas.Handle, PX, PY, 0, nil, ScreenPtr(X1, Y1), X2 - X1, nil);
  1270.     Inc(Y1);
  1271.     Inc(PY, FCharSize.Y);
  1272.   end;
  1273. end;
  1274.  
  1275. procedure TConsole.WMSize(var M: TWMSize);
  1276. var
  1277.   W,H: Integer;
  1278. begin
  1279.   if FFocused and (FReading or (coFullTimeCursor in Options)) then
  1280.     HideCursor;
  1281.   inherited;
  1282.   RecalcSizeAndRange;
  1283.   if FFocused and (FReading or (coFullTimeCursor in Options)) then
  1284.     ShowCursor;
  1285. end;
  1286.  
  1287.  
  1288. procedure TConsole.DoScroll(Which, Action, Thumb: Integer);
  1289. var
  1290.   X, Y: Integer;
  1291.  
  1292.   function GetNewPos(Pos, Page, Range: Integer): Integer;
  1293.   begin
  1294.     case Action of
  1295.       sb_LineUp: GetNewPos := Pos - 1;
  1296.       sb_LineDown: GetNewPos := Pos + 1;
  1297.       sb_PageUp: GetNewPos := Pos - Page;
  1298.       sb_PageDown: GetNewPos := Pos + Page;
  1299.       sb_Top: GetNewPos := 0;
  1300.       sb_Bottom: GetNewPos := Range;
  1301.       sb_ThumbPosition,
  1302.       sb_ThumbTrack    : GetNewPos := Thumb;
  1303.     else
  1304.       GetNewPos := Pos;
  1305.     end;
  1306.   end;
  1307.  
  1308. begin
  1309.   X := FOrigin.X;
  1310.   Y := FOrigin.Y;
  1311.   case Which of
  1312.     sb_Horz: X := GetNewPos(X, FClientSize.X div 2, FRange.X);
  1313.     sb_Vert: Y := GetNewPos(Y, FClientSize.Y, FRange.Y);
  1314.   end;
  1315.   ScrollTo(X, Y);
  1316. end;
  1317.  
  1318. procedure TConsole.WMHScroll(var M: TWMHScroll);
  1319. begin
  1320.   DoScroll(sb_Horz, M.ScrollCode, M.Pos);
  1321. end;
  1322.  
  1323. procedure TConsole.WMVScroll(var M: TWMVScroll);
  1324. begin
  1325.   DoScroll(sb_Vert, M.ScrollCode, M.Pos);
  1326. end;
  1327.  
  1328. procedure TConsole.KeyPress(var Key: Char);
  1329. begin
  1330.   inherited KeyPress(Key);
  1331.   if Key <> #0 then
  1332.   begin
  1333.     if (coCheckBreak in Options) and (Key = #3) then
  1334.       DoCtrlBreak;
  1335.     if FKeyCount < SizeOf(FKeyBuffer) then
  1336.     begin
  1337.       FKeyBuffer[FKeyCount] := Key;
  1338.       Inc(FKeyCount);
  1339.     end;
  1340.   end;
  1341. end;
  1342.  
  1343. procedure TConsole.KeyDown(var Key: Word; Shift: TShiftState);
  1344. var
  1345.   I: Integer;
  1346. begin
  1347.   inherited KeyDown(Key, Shift);
  1348.   if Key = 0 then Exit;
  1349.   if (coCheckBreak in Options) and (Key = vk_Cancel) then
  1350.     DoCtrlBreak;
  1351.   for I := 1 to ScrollKeyCount do
  1352.     with ScrollKeys[I] do
  1353.       if (sKey = Key) and (Ctrl = (Shift = [ssCtrl])) then
  1354.       begin
  1355.         DoScroll(SBar, Action, 0);
  1356.         Exit;
  1357.       end;
  1358. end;
  1359.  
  1360. procedure TConsole.WMSetFocus(var M: TWMSetFocus);
  1361. begin
  1362.   FFocused := True;
  1363.   if FReading or (coFullTimeCursor in Options) then
  1364.     ShowCursor;
  1365.   inherited;
  1366. end;
  1367.  
  1368. procedure TConsole.WMKillFocus(var M: TWMKillFocus);
  1369. begin
  1370.   inherited;
  1371.   if FReading or (coFullTimeCursor in Options) then
  1372.     HideCursor;
  1373.   FFocused := False;
  1374. end;
  1375.  
  1376. procedure TConsole.WMGetDlgCode(var M: TWMGetDlgCode);
  1377. begin
  1378.   M.Result := dlgc_WantArrows or dlgc_WantChars;
  1379. end;
  1380.  
  1381. procedure TConsole.WMEraseBkgnd(var M: TWMEraseBkgnd);
  1382. begin
  1383.   M.Result := 1;
  1384. end;
  1385.  
  1386. procedure TConsole.DoCtrlBreak;
  1387. begin
  1388. end;
  1389.  
  1390. procedure TConsole.MouseDown(Button: TMouseButton;
  1391.   Shift: TShiftState; X, Y: Integer);
  1392. begin
  1393.   SetFocus;
  1394.   inherited MouseDown(Button, Shift, X, Y);
  1395. end;
  1396.  
  1397.  
  1398.  
  1399. {****************  TAttrManager  ****************}
  1400.  
  1401. constructor TAttr.Create(F: TFixedFont);
  1402. var
  1403.   DC: HDC;
  1404.   Save: THandle;
  1405.   TM: TTextMetric;
  1406. begin
  1407.   inherited Create;
  1408.   Assign(F);
  1409.   BkColor := F.BkColor;
  1410.   DC := GetDC(0);
  1411.   Save := SelectObject(DC, F.Handle);
  1412.   GetTextMetrics(DC, TM);
  1413.   SelectObject(DC, Save);
  1414.   ReleaseDC(0,DC);
  1415.   Overhang := TM.tmOverhang;
  1416.   Underhang := MulDiv(TM.tmDescent, TM.tmOverhang, TM.tmAscent);
  1417. end;
  1418.  
  1419.  
  1420. {****************  TAttrManager  ****************}
  1421.  
  1422. { The list of free slots in the TAttrManager's FList is
  1423.   maintained in the unused pointer slots inside the FList.
  1424.   FFreeList is the index of the first free slot, or -1 if
  1425.   there are no free slots.  The pointer FList[FFreeList]
  1426.   contains the negative of the integer index of the next
  1427.   free slot, and so on. In 16 bit, this code assumes $FFFF
  1428.   will never appear as a selector.  In 32 bit, this code
  1429.   would assume FList indexes and pointers stored in the
  1430.   FList are positive (>=0) when evaluated as signed integers.
  1431. }
  1432.  
  1433. const
  1434.   EndOfList = -MaxInt;
  1435.  
  1436. constructor TAttrManager.Create;
  1437. begin
  1438.   inherited Create;
  1439.   FList := TList.Create;
  1440. end;
  1441.  
  1442. destructor TAttrManager.Destroy;
  1443. begin
  1444.   Clear;
  1445.   FList.Free;
  1446.   inherited Destroy;
  1447. end;
  1448.  
  1449. function TAttrManager.GetCount;
  1450. begin
  1451.   Result := FList.Count;
  1452. end;
  1453.  
  1454. function  TAttrManager.InFreeList(P: Pointer): Boolean;
  1455. begin
  1456.   Result := (EndOfList <= Longint(P)) and (Longint(P) < 0);
  1457. end;
  1458.  
  1459. function  TAttrManager.FirstFreeIndex: Integer;
  1460. begin
  1461.   Result := FFreeList;
  1462. end;
  1463.  
  1464. function  TAttrManager.NextFreeIndex(P: Pointer): Integer;
  1465. begin
  1466.   if (EndOfList < Longint(P)) and (Longint(P) < 0) then
  1467.     Result := -Longint(P) - 1
  1468.   else
  1469.     Result := -1;
  1470. end;
  1471.  
  1472. procedure TAttrManager.SetFree(Index: Integer);
  1473. begin
  1474.   if FFreeList < 0 then
  1475.     FList[Index] := Pointer(Longint(EndOfList))
  1476.   else
  1477.     FList[Index] := Pointer(Longint(-FFreeList - 1));
  1478.   FFreeList := Index;
  1479. end;
  1480.  
  1481. function TAttrManager.AllocIndex: Integer;
  1482. begin
  1483.   if FFreeList >= 0 then
  1484.   begin
  1485.     Result := FFreeList;
  1486.     FFreeList := NextFreeIndex(FList[FFreeList]);
  1487.   end
  1488.   else
  1489.     Result := FList.Count;
  1490. end;
  1491.  
  1492. function  TAttrManager.Allocate(F: TFixedFont): Integer;
  1493. var
  1494.   P: ^Pointer;
  1495.   H: THandle;
  1496.   C,B: TColor;
  1497.   N: Integer;
  1498. begin
  1499.   Result := FCacheIndex;
  1500.   with F do
  1501.   begin
  1502.     C := Color;
  1503.     B := BkColor;
  1504.     H := Handle;
  1505.   end;
  1506.   if FCache <> nil then
  1507.   with FCache do
  1508.     if (Color = C) and (BkColor = B) and (Handle = H) then
  1509.       Exit;
  1510.  
  1511.   { Search for a match }
  1512.   Result := FList.Count;
  1513.   P := Pointer(FList.List);  { Use pointer iterator instead of For loop }
  1514.   while (Result > 0) do
  1515.   begin
  1516.     if not InFreeList(P^) then
  1517.     with TAttr(P^) do
  1518.       if (Color = C) and (BkColor = B) and (Handle = H) then
  1519.       begin
  1520.         FCache := TAttr(P^);
  1521.         Result := FList.Count - Result;
  1522.         FCacheIndex := Result;
  1523.         Exit;
  1524.       end;
  1525.     Inc(P);
  1526.     Dec(Result);
  1527.   end;
  1528.  
  1529.   { No match found, so create a new TAttr in an empty slot }
  1530.   Result := AllocIndex;
  1531.   Attr[Result] := TAttr.Create(F);
  1532. end;
  1533.  
  1534. procedure TAttrManager.Clear;
  1535. var
  1536.   I: Integer;
  1537. begin
  1538.   for I := 0 to FList.Count - 1 do
  1539.     if not InFreeList(FList[I]) then
  1540.       TObject(FList[I]).Free;
  1541.   FList.Clear;
  1542.   FCacheIndex := 0;
  1543.   FCache := nil;
  1544.   FFreeList := -1;
  1545. end;
  1546.  
  1547. procedure TAttrManager.Reference(Index: Integer; Delta: Integer);
  1548. begin
  1549.   with Attr[Index] do
  1550.   begin
  1551.     Inc(RefCount, Delta);
  1552.     if RefCount <= 0 then
  1553.       Attr[Index] := nil;
  1554.   end;
  1555. end;
  1556.  
  1557. function  TAttrManager.GetAttr(Index: Integer): TAttr;
  1558. begin
  1559.   Result := TAttr(FList[Index]);
  1560.   if InFreeList(Result) then
  1561.     Result := nil;
  1562. end;
  1563.  
  1564. procedure TAttrManager.SetAttr(Index: Integer; NewAttr: TAttr);
  1565. var
  1566.   Temp: TAttr;
  1567. begin
  1568.   if NewAttr = nil then
  1569.   begin
  1570.     TObject(FList[Index]).Free;
  1571.     SetFree(Index);
  1572.   end
  1573.   else
  1574.     if Index = FList.Count then
  1575.       FList.Expand.Add(NewAttr)
  1576.     else
  1577.       FList[Index] := NewAttr;
  1578.   FCacheIndex := Index;
  1579.   FCache := NewAttr;
  1580. end;
  1581.  
  1582.  
  1583. { *************  TColorConsole *************** }
  1584.  
  1585. constructor TColorConsole.Create(Owner: TComponent);
  1586. begin
  1587.   FAttrList := TAttrManager.Create;
  1588.   inherited Create(Owner);
  1589. end;
  1590.  
  1591. destructor TColorConsole.Destroy;
  1592. begin
  1593.   inherited Destroy;
  1594.   StrDispose(Pointer(FIndexes));
  1595.   FAttrList.Free;
  1596.   StrDispose(Pointer(FCellWidths));
  1597. end;
  1598.  
  1599. function TColorConsole.IndexPtr(X,Y: Integer): PInteger;
  1600. begin
  1601.   Result := @FIndexes^[Longint(ScreenPtr(X,Y)) - Longint(FBuffer)];
  1602. end;
  1603.  
  1604. { ResizeBuffer
  1605.    - Called by constructor to init buffers, and called by SetCols/SetRows
  1606.      when Cols or Rows change.  Cols and Rows will be set to their new
  1607.      values before ResizeBuffer is called.
  1608.    - StrAlloc will fail (raise xptn) if Cols * Rows is greater than 32k - 2
  1609.    - No attempt is made to preserve the contents of the buffers.  Resizing
  1610.    the buffers is equivallent to a ClrScr.
  1611. }
  1612.  
  1613. procedure TColorConsole.ResizeBuffer;
  1614. var
  1615.   I: Integer;
  1616.   A: Integer;
  1617.   P: PInteger;
  1618.   P2: Pointer;
  1619. begin
  1620.   inherited ResizeBuffer;
  1621.   Pointer(P) := nil;
  1622.   P2 := nil;
  1623.   try
  1624.     Pointer(P) := StrAlloc(Longint(Cols) * Rows * Sizeof(Integer));
  1625.     P2 := StrAlloc(Cols * SizeOf(Integer));
  1626.     Exchange(Pointer(FIndexes), Pointer(P));
  1627.     Exchange(Pointer(FCellWidths), P2);
  1628.   finally
  1629.     StrDispose(Pointer(P));
  1630.     StrDispose(P2);
  1631.   end;
  1632.   FAttrList.Clear;
  1633.   A := FAttrList.Allocate(Font);
  1634.   FillInt(FIndexes^, Cols * Rows, A);
  1635.   FAttrList.Reference(A, Cols * Rows );
  1636.   FillInt(FCellWidths^, Cols, FCharSize.X);
  1637. end;
  1638.  
  1639. { If the character cell is larger, expand settings and redraw }
  1640. procedure TColorConsole.SetMetrics(const Metrics: TTextMetric);
  1641. var
  1642.   Changed: Boolean;
  1643.   I: Integer;
  1644.   A: TAttr;
  1645.  
  1646.   function Check(A, B: Longint): Longint;
  1647.   begin
  1648.     Result := A;
  1649.     if A < B then
  1650.     begin
  1651.       Result := B;
  1652.       Changed := True;
  1653.     end;
  1654.   end;
  1655.  
  1656. begin
  1657.     { Different fonts of the same point size have slightly different char
  1658.       cells.  Keep the global char cell large enough for all. }
  1659.   if FOldFont.Size = Font.Size then
  1660.   with Metrics do
  1661.   begin
  1662.     Changed := False;              { TT fonts don't report overhang }
  1663.     FOverhang := Check(FOverhang, Max(tmOverhang, tmMaxCharWidth - tmAveCharWidth));
  1664.     FCharSize.X := Check(FCharSize.X, tmAveCharWidth);
  1665.     FCharSize.Y := Check(FCharSize.Y, tmHeight + tmExternalLeading);
  1666.     FCharAscent := Check(FCharAscent, tmAscent);
  1667.     if Changed then
  1668.     begin
  1669.       if FCellWidths <> nil then
  1670.         FillInt(FCellWidths^, Cols, FCharSize.X);
  1671.       RecalcSizeAndRange;
  1672.       Invalidate;
  1673.     end;
  1674.   end
  1675.   else
  1676.   begin { If font size changed, accept new cell verbatim. }
  1677.     { Update all cached fonts to new size }
  1678.     for I := 0 to FAttrList.Count - 1 do
  1679.     begin
  1680.       A:= FAttrList[I];
  1681.       if A <> nil then
  1682.         A.Size := Font.Size;
  1683.     end;
  1684.     if FCellWidths <> nil then
  1685.       FillInt(FCellWidths^, Cols, Metrics.tmAveCharWidth);
  1686.     inherited SetMetrics(Metrics);
  1687.   end;
  1688. end;
  1689.  
  1690.  
  1691. procedure TColorConsole.WriteFill(X,Y: Integer; Ch: Char; Count: Cardinal);
  1692. begin
  1693.   if Count = 0 then Exit;
  1694.   FillAttr(X,Y,Count);
  1695.   inherited WriteFill(X,Y,Ch,Count);  { write ch to the char buffer }
  1696. end;
  1697.  
  1698. procedure TColorConsole.FillAttr(X,Y: Integer; Count: Cardinal);
  1699.  
  1700.   procedure ReplaceAttr(A: Integer; P: PInteger; Count: Cardinal);
  1701.   var
  1702.     RunCount: Integer;
  1703.     RunValue: Integer;
  1704.   begin
  1705.     while Count > 0 do
  1706.     begin
  1707. {$IFDEF Win32}
  1708.       RunValue := P^;
  1709.       RunCount := 0;
  1710.       repeat
  1711.         P^ := A;
  1712.         Inc(P);
  1713.         Inc(RunCount);
  1714.       until (RunCount >= Count) or (P^ <> RunValue);
  1715. {$ELSE}
  1716.       asm
  1717.         LES   DI, P
  1718.         MOV   SI, DI
  1719.         MOV   AX, ES:[DI]
  1720.         MOV   CX, Count
  1721.         MOV   DX, CX
  1722.         REPE  SCASW
  1723.         JZ    @@1
  1724.         INC   CX
  1725.         DEC   DI
  1726.         DEC   DI
  1727.       @@1:
  1728.         SUB   DX, CX
  1729.         MOV   RunCount, DX
  1730.         MOV   RunValue, AX
  1731.         MOV   P.Word[0], DI
  1732.         CMP   AX, A         { If attrs are same, no need to write over them. }
  1733.         JE    @@2
  1734.         MOV   DI, SI
  1735.         MOV   CX, DX
  1736.         MOV   AX, A
  1737.         REP   STOSW
  1738.       @@2:
  1739.       end;
  1740. {$ENDIF}
  1741.       FAttrList.Reference(RunValue, -RunCount);
  1742.       Dec(Count, RunCount);
  1743.     end;
  1744.   end;
  1745.  
  1746. var
  1747.   A: Integer;
  1748.   I: Integer;
  1749. begin
  1750.   A := FAttrList.Allocate(Font);
  1751.   FAttrList.Reference(A, Count);
  1752.   if (X + Count) > Cols then
  1753.   begin
  1754.     ReplaceAttr(A, IndexPtr(X,Y), Cols - X);
  1755.     Dec(Count, Cols - X);
  1756.     I := Cols;
  1757.     while Count > 0 do
  1758.     begin
  1759.       Inc(Y);
  1760.       ReplaceAttr(A, IndexPtr(X,Y), I);
  1761.       Dec(Count, I);
  1762.     end;
  1763.   end
  1764.   else
  1765.     ReplaceAttr(A, IndexPtr(X,Y), Count);
  1766. end;
  1767.  
  1768. procedure TColorConsole.WriteBlock(X,Y: Integer; Buffer: PChar; Count: Cardinal);
  1769. begin
  1770.   if Count = 0 then Exit;
  1771.   FillAttr(X,Y,Count);                     { fill range with current attr }
  1772.   inherited WriteBlock(X,Y,Buffer,Count);  { copy chars to char buf }
  1773. end;
  1774.  
  1775. procedure TColorConsole.Paint;
  1776. var
  1777.   X1, X2, Y1, Y2, RunValue, RunStart, RunEnd, Len, Count, Prev: Integer;
  1778.   R: TRect;
  1779.   P: PInteger;
  1780.   Buf: PChar;
  1781.   A: TAttr;
  1782.   C: TPoint;
  1783.   DC: HDC;
  1784. begin
  1785.   C := FCharSize;
  1786.   SetViewportOrgEx(Canvas.Handle, -FOrigin.X * FCharSize.X, -FOrigin.Y * C.Y, nil);
  1787.   GetClipBox(Canvas.Handle, R);
  1788.   X1 := Max(FOrigin.X, (R.left - FOverhang) div C.X);
  1789.   X2 := Min(Cols, (R.right + C.X) div C.X);
  1790.   Y1 := Max(0, R.top div C.Y);
  1791.   Y2 := Min(Rows, (R.bottom + C.Y - 1) div C.Y);
  1792.   if ((Cols * C.X) < R.Right) then
  1793.   begin
  1794.     Canvas.Brush := Brush;
  1795.     Count := R.Left;
  1796.     R.Left := Cols * C.X;
  1797.     Canvas.FillRect(R);
  1798.     R.Right := R.Left;
  1799.     R.Left := Count;
  1800.   end;
  1801.   if (Rows * C.Y) < R.Bottom then
  1802.   begin
  1803.     Canvas.Brush := Brush;
  1804.     R.Top := Rows * C.Y;
  1805.     Canvas.FillRect(R);
  1806.   end;
  1807.     { In this tight display loop, we don't need all the automatic services
  1808.       provided by TCanvas.  To optimize performance, we'll select the text
  1809.       font and colors into the DC 'manually'. }
  1810.   DC := Canvas.Handle;
  1811.   SetBkMode(DC, OPAQUE);
  1812.   SetTextAlign(DC, TA_BaseLine);
  1813.   R.Top := Y1 * C.Y;
  1814.   R.Bottom := R.Top + C.Y;
  1815.   Prev := -1;
  1816.   while Y1 < Y2 do
  1817.   begin
  1818.     Buf := ScreenPtr(X1,Y1);
  1819.     P := Pointer(IndexPtr(X1,Y1));
  1820.     Count := X2 - X1;
  1821.     R.Left := X1 * C.X;
  1822. {$IFDEF WIN32}
  1823.     RunEnd := Integer(P) + Count * sizeof(Integer);
  1824.     while Count > 0 do
  1825.     begin
  1826.       RunStart := Integer(P);
  1827.       RunValue := P^;
  1828.       while (Integer(P) < RunEnd) and (P^ = RunValue) do
  1829.         Inc(P);
  1830.       Len := (Integer(P) - RunStart) div sizeof(Integer);
  1831.       Dec(Count, Len);
  1832. {$ELSE}
  1833.     RunEnd := X1;
  1834.     while Count > 0 do
  1835.     begin
  1836.       asm
  1837.         LES   DI, P
  1838.         MOV   AX, ES:[DI]   { AX := P^ }
  1839.         MOV   CX, Count
  1840.         MOV   BX, CX
  1841.         REPE  SCASW
  1842.         JZ    @@1
  1843.         INC   CX
  1844.         DEC   DI
  1845.         DEC   DI
  1846.       @@1:
  1847.         MOV   P.Word[0], DI
  1848.         MOV   RunValue, AX
  1849.         SUB   BX, CX
  1850.         MOV   Count, CX
  1851.         MOV   Len, BX
  1852.         ADD   RunEnd, BX    { RunEnd := RunStart + Length }
  1853.       end;
  1854. {$ENDIF}
  1855.       if RunValue <> Prev then   { Only select objects when we have to }
  1856.       begin                      { (this helps at line breaks )        }
  1857.         A := FAttrList[RunValue];
  1858.         SelectObject(DC, A.Handle);
  1859.         SetTextColor(DC, ColorToRGB(A.Color));
  1860.         SetBkColor(DC, ColorToRGB(A.BkColor));
  1861.         Prev := RunValue;
  1862.       end;
  1863.       R.Right := R.Left + Len * C.X;
  1864.       ExtTextOut(DC, R.Left - A.Underhang, R.Top + FCharAscent,
  1865.         ETO_Opaque or ETO_Clipped, @R, Buf, Len, Pointer(FCellWidths));
  1866.       R.Left := R.Right;
  1867.       Inc(Buf, Len);
  1868.     end;
  1869.     Inc(Y1);
  1870.     Inc(R.Top, C.Y);
  1871.     Inc(R.Bottom, C.Y);
  1872.   end;
  1873.    { Since we've manipulated the DC directly, and the canvas may think its
  1874.      current objects are still selected, we should force the canvas to
  1875.      deselect all GDI objects }
  1876.   Canvas.Handle := 0;
  1877. end;
  1878.  
  1879.  
  1880. procedure Register;
  1881. begin
  1882.   RegisterComponents('Additional', [TConsole, TColorConsole]);
  1883.   RegisterClasses([TFixedFont]);
  1884. end;
  1885.  
  1886.  
  1887. end.
  1888.  
  1889.  
  1890.  
  1891.  
  1892.